home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / pointers.swg / 0025_Avl Tree Tally.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-24  |  7.4 KB  |  222 lines
  1. (*
  2. Here is TALLY.PAS, a program that Matt Bousek <MBOUSEK@intel9.intel.com> wrote
  3. to do a word frequency analysis on a text file.  It uses an AVL tree.  It
  4. should compile under TP 6.0 or BP 7.0
  5. *)
  6. program word_freq(input,output);
  7.  
  8. type
  9.     short_str = string[32];
  10.  
  11. {************AVLtree routines*********}
  12. type
  13.     balance_set = (left_tilt,neutral,right_tilt);
  14.     memptr      = ^memrec;
  15.     memrec = record
  16.         balance     : balance_set;
  17.         left,right  : memptr;
  18.         count       : longint;
  19.         key         : short_str;
  20.     end;
  21.  
  22.     {**************************************}
  23.     procedure rotate_right(var root:memptr);
  24.     var ptr2,ptr3 : memptr;
  25.     begin
  26.         ptr2:=root^.right;
  27.         if ptr2^.balance=right_tilt then begin
  28.             root^.right:=ptr2^.left;
  29.             ptr2^.left:=root;
  30.             root^.balance:=neutral;
  31.             root:=ptr2;
  32.         end else begin
  33.             ptr3:=ptr2^.left;
  34.             ptr2^.left:=ptr3^.right;
  35.             ptr3^.right:=ptr2;
  36.             root^.right:=ptr3^.left;
  37.             ptr3^.left:=root;
  38.             if ptr3^.balance=left_tilt
  39.                 then ptr2^.balance:=right_tilt
  40.                 else ptr2^.balance:=neutral;
  41.             if ptr3^.balance=right_tilt
  42.                 then root^.balance:=left_tilt
  43.                 else root^.balance:=neutral;
  44.             root:=ptr3;
  45.         end;
  46.         root^.balance:=neutral;
  47.     end;
  48.  
  49.     {*************************************}
  50.     procedure rotate_left(var root:memptr);
  51.     var ptr2,ptr3 : memptr;
  52.     begin
  53.         ptr2:=root^.left;
  54.         if ptr2^.balance=left_tilt then begin
  55.             root^.left:=ptr2^.right;
  56.             ptr2^.right:=root;
  57.             root^.balance:=neutral;
  58.             root:=ptr2;
  59.         end else begin
  60.             ptr3:=ptr2^.right;
  61.             ptr2^.right:=ptr3^.left;
  62.             ptr3^.left:=ptr2;
  63.             root^.left:=ptr3^.right;
  64.             ptr3^.right:=root;
  65.             if ptr3^.balance=right_tilt
  66.                 then ptr2^.balance:=left_tilt
  67.                 else ptr2^.balance:=neutral;
  68.             if ptr3^.balance=left_tilt
  69.                 then root^.balance:=right_tilt
  70.                 else root^.balance:=neutral;
  71.             root:=ptr3;
  72.         end;
  73.         root^.balance:=neutral;
  74.     end;
  75.  
  76.     {*****************************************************************}
  77.     procedure insert_mem(var root:memptr; x:short_str; var ok:boolean);
  78.     begin
  79.         if root=nil then begin
  80.             new(root);
  81.             with root^ do begin
  82.                 key:=x;
  83.                 left:=nil;
  84.                 right:=nil;
  85.                 balance:=neutral;
  86.                 count:=1;
  87.             end;
  88.             ok:=true;
  89.         end else begin
  90.             if x=root^.key then begin
  91.                 ok:=false;
  92.                 inc(root^.count);
  93.             end else begin
  94.                 if x<root^.key then begin
  95.                     insert_mem(root^.left,x,ok);
  96.                     if ok then case root^.balance of
  97.                         left_tilt  : begin
  98.                                 rotate_left(root);
  99.                                 ok:=false;
  100.                             end;
  101.                         neutral    : root^.balance:=left_tilt;
  102.                         right_tilt : begin
  103.                                 root^.balance:=neutral;
  104.                                 ok:=false;
  105.                             end;
  106.                     end;
  107.                 end else begin
  108.                     insert_mem(root^.right,x,ok);
  109.                     if ok then case root^.balance of
  110.                         left_tilt  : begin
  111.                                 root^.balance:=neutral;
  112.                                 ok:=false;
  113.                             end;
  114.                         neutral    : root^.balance:=right_tilt;
  115.                         right_tilt : begin
  116.                                 rotate_right(root);
  117.                                 ok:=false;
  118.                             end;
  119.                     end;
  120.                 end;
  121.             end;
  122.         end;
  123.     end;
  124.  
  125.     {*****************************************************}
  126.     procedure insert_memtree(var root:memptr; x:short_str);
  127.     var ok:boolean;
  128.     begin
  129.         ok:=false;
  130.         insert_mem(root,x,ok);
  131.     end;
  132.  
  133.     {*********************************}
  134.     procedure dump_mem(var root:memptr);
  135.     begin
  136.         if root<>nil then begin
  137.             dump_mem(root^.left);
  138.             writeln(root^.count:5,' ',root^.key);
  139.             dump_mem(root^.right);
  140.         end;
  141.     end;
  142.  
  143.  
  144. {MAIN***************************************************************}
  145. {*** This program was written by Matt Bousek sometime in 1992.   ***}
  146. {*** The act of this posting over Internet makes the code public ***}
  147. {*** domain, but it would be nice to keep this header.           ***}
  148. {*** The basic AVL routines came from a book called "Turbo Algo- ***}
  149. {*** rythms",  Sorry, I don't have the book here and I can't     ***}
  150. {*** remember the authors or publisher.  Enjoy.  And remember,   ***}
  151. {*** there is no free lunch...                                   ***}
  152.  
  153. const
  154.     wchars:set of char=['''','a'..'z'];
  155.  
  156. var
  157.     i,j         : word;
  158.     aword       : short_str;
  159.     subject     : text;
  160.     wstart,wend : word;
  161.     inword      : boolean;
  162.     linecount   : longint;
  163.     wordcount   : longint;
  164.     buffer      : array[1..10240] of char;
  165.     line        : string;
  166.     filename    : string;
  167.     tree        : memptr;
  168.  
  169. BEGIN
  170.     tree:=nil;
  171.  
  172.     filename:=paramstr(1);
  173.     if filename='' then filename:='tally.pas';
  174.     assign(subject,filename);
  175.     settextbuf(subject,buffer);
  176.     reset(subject);
  177.  
  178.     wordcount:=0;
  179.     linecount:=0;
  180.     while not eof(subject) do begin
  181.         inc(linecount);
  182.         readln(subject,line);
  183.         wstart:=0; wend:=0;
  184.         for i:=1 to byte(line[0]) do begin
  185.             if line[i] in ['A'..'Z'] then line[i]:=chr(ord(line[i])+32);
  186.             inword:=(line[i] in wchars);
  187.             if inword and (wstart=0) then wstart:=i;
  188.             if inword and (wstart>0) then wend:=i;
  189.             if not(inword) or (i=byte(line[0])) then begin
  190.                 if wend>wstart then begin
  191.                     aword:=copy(line,wstart,wend+1-wstart);
  192.                     j:=byte(aword[0]);
  193.                     if (aword[j]='''') and (j>2) then begin {lose trailing '}
  194.                         aword:=copy(aword,1,j-1);
  195.                         dec(wend);
  196.                         dec(j);
  197.                     end;
  198.                     if (aword[1]='''') and (j>2) then begin {lose leading '}
  199.                         aword:=copy(aword,2,j-1);
  200.                         inc(wstart);
  201.                         dec(j);
  202.                     end;
  203.                     if (j>2) and (aword[j-1]='''') and (aword[j]='s') then
  204. begin {lose trailing 's}
  205.                         aword:=copy(aword,1,j-2);
  206.                         dec(wend,2);
  207.                         dec(j,2);
  208.                     end;
  209.                     if (j>2) then begin
  210.                         inc(wordcount);
  211.                         insert_memtree(tree,aword);
  212.                     end;
  213.                 end; { **if wend>wstart** }
  214.                 wstart:=0; wend:=0;
  215.             end; { **if not(inword)** }
  216.         end; { **for byte(line[0])** }
  217.     end; { **while not eof** }
  218.  
  219. dump_mem(tree);
  220. writeln(linecount,' lines, ',wordcount,' words.');
  221. END.
  222.